hogwarts <- read_csv("data/hogwarts_2024.csv")
hogwarts |> head()
## # A tibble: 6 × 60
## id house course sex wandCore bloodStatus result Defence against the …¹
## <dbl> <chr> <dbl> <chr> <chr> <chr> <dbl> <dbl>
## 1 1 Ravencl… 4 fema… unicorn… half-blood 94 73
## 2 2 Hufflep… 5 male phoenix… half-blood 33 38
## 3 3 Ravencl… 4 fema… dragon … half-blood 137 52
## 4 4 Hufflep… 2 male phoenix… half-blood 27 50
## 5 5 Hufflep… 2 fema… phoenix… half-blood 67 47
## 6 6 Gryffin… 6 male phoenix… muggle-born 126 44
## # ℹ abbreviated name: ¹`Defence against the dark arts exam`
## # ℹ 52 more variables: `Flying exam` <dbl>, `Astronomy exam` <dbl>,
## # `Herbology exam` <dbl>, `Divinations exam` <dbl>, `Charms exam` <dbl>,
## # `History of magic exam` <dbl>, `Arithmancy exam` <dbl>,
## # `Care of magical creatures exam` <dbl>, `Muggle studies exam` <dbl>,
## # `Study of ancient runes exam` <dbl>, `Transfiguration exam` <dbl>,
## # `Potions exam` <dbl>, week_1 <dbl>, week_2 <dbl>, week_3 <dbl>, …
hogwarts |> glimpse()
## Rows: 560
## Columns: 60
## $ id <dbl> 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11…
## $ house <chr> "Ravenclaw", "Hufflepuff", "Raven…
## $ course <dbl> 4, 5, 4, 2, 2, 6, 7, 5, 2, 3, 7, …
## $ sex <chr> "female", "male", "female", "male…
## $ wandCore <chr> "unicorn hair", "phoenix feather"…
## $ bloodStatus <chr> "half-blood", "half-blood", "half…
## $ result <dbl> 94, 33, 137, 27, 67, 126, 63, 7, …
## $ `Defence against the dark arts exam` <dbl> 73, 38, 52, 50, 47, 44, 51, 47, 2…
## $ `Flying exam` <dbl> 33, 36, 73, 42, 41, 52, 34, 34, 2…
## $ `Astronomy exam` <dbl> 57, 45, 66, 49, 57, 59, 58, 37, 5…
## $ `Herbology exam` <dbl> 73, 50, 62, 39, 38, 46, 59, 23, 2…
## $ `Divinations exam` <dbl> 66, 54, 72, 42, 47, 49, 42, 38, 1…
## $ `Charms exam` <dbl> 60, 70, 77, 46, 35, 55, 86, 20, 4…
## $ `History of magic exam` <dbl> 52, 36, 60, 45, 50, 40, 55, 21, 2…
## $ `Arithmancy exam` <dbl> 61, 36, 58, 32, 76, 50, 41, 31, 2…
## $ `Care of magical creatures exam` <dbl> 44, 41, 70, 36, 46, 73, 29, 36, 4…
## $ `Muggle studies exam` <dbl> 64, 34, 52, 59, 50, 54, 36, 31, 4…
## $ `Study of ancient runes exam` <dbl> 50, 35, 59, 39, 48, 56, 47, 41, 3…
## $ `Transfiguration exam` <dbl> 74, 70, 70, 15, 32, 86, 100, 31, …
## $ `Potions exam` <dbl> 67, 38, 22, 64, 56, 60, 62, 55, 1…
## $ week_1 <dbl> 0, -5, 0, -1, 1, 5, 1, -20, 3, -2…
## $ week_2 <dbl> -10, 1, 0, 5, 20, 10, -5, 10, 1, …
## $ week_3 <dbl> 0, -1, 1, -5, 10, -5, 3, -5, -3, …
## $ week_4 <dbl> 10, 1, -1, 10, -10, 10, 0, -10, -…
## $ week_5 <dbl> 3, -5, 3, 0, -1, 20, 5, 5, -3, 5,…
## $ week_6 <dbl> -20, 20, 0, 0, 0, 0, 0, 5, 0, -1,…
## $ week_7 <dbl> 10, 10, 1, -3, -20, 1, 10, 3, -5,…
## $ week_8 <dbl> 5, 5, 1, -5, 5, 5, 0, 1, 0, 20, -…
## $ week_9 <dbl> 1, 1, 3, -1, 0, 3, -20, -20, -10,…
## $ week_10 <dbl> 20, -10, 1, 5, -1, 0, 5, -5, 5, 3…
## $ week_11 <dbl> 5, -10, 20, 0, 0, 0, 5, 10, 5, 5,…
## $ week_12 <dbl> 5, -5, 1, -20, -10, -5, 0, 5, 1, …
## $ week_13 <dbl> -20, -5, 10, 0, 0, 1, -1, 10, -20…
## $ week_14 <dbl> 0, 5, 3, 10, -10, 20, 0, -20, -20…
## $ week_15 <dbl> 1, 20, 1, 0, -20, 10, 1, 3, -20, …
## $ week_16 <dbl> 20, 5, 5, 5, 0, 3, 10, -1, 5, 5, …
## $ week_17 <dbl> 3, 0, 10, 5, 5, -5, -1, 10, -10, …
## $ week_18 <dbl> 10, 5, 5, 5, 10, -20, 0, 10, 3, 5…
## $ week_19 <dbl> -10, 0, -5, -1, 0, -1, 0, 20, 0, …
## $ week_20 <dbl> 10, -10, 5, 10, 0, -1, -1, 10, 0,…
## $ week_21 <dbl> 0, 5, 5, 3, 5, 0, 0, -5, -5, 5, 5…
## $ week_22 <dbl> 20, -5, 5, 0, 20, 5, -1, 0, 0, 20…
## $ week_23 <dbl> 5, 1, -3, 20, -5, 20, 0, 1, 1, 5,…
## $ week_24 <dbl> 10, -20, -20, 0, 10, 5, 5, -3, -5…
## $ week_25 <dbl> 0, -20, 1, 3, 5, 1, -5, 0, -20, 2…
## $ week_26 <dbl> 10, 10, 5, -1, 0, 5, 5, -3, 0, 20…
## $ week_27 <dbl> 5, 5, -3, 0, 20, 5, 0, -5, 10, 3,…
## $ week_28 <dbl> -3, 20, 20, 1, 10, 5, 1, 10, 0, 1…
## $ week_29 <dbl> -20, -5, 5, 5, -10, 1, 0, -3, 0, …
## $ week_30 <dbl> 5, 1, -5, 5, -5, -1, -20, 20, 1, …
## $ week_31 <dbl> 5, 5, 20, -5, -10, -3, 0, -10, 20…
## $ week_32 <dbl> -5, 1, 20, -1, -10, 5, 10, 1, 0, …
## $ week_33 <dbl> 0, 10, 3, 3, 0, 0, -1, 0, -20, 3,…
## $ week_34 <dbl> 0, -1, 0, 0, 10, 3, 20, -5, 10, 3…
## $ week_35 <dbl> 5, -5, 3, -10, 3, -5, 0, 0, 0, 0,…
## $ week_36 <dbl> 1, 5, 1, -20, 5, 20, -1, -3, 1, 3…
## $ week_37 <dbl> 0, 0, 10, -1, 10, 3, 3, 0, 20, 1,…
## $ week_38 <dbl> 10, -1, 0, -5, 5, 5, 20, -5, -3, …
## $ week_39 <dbl> 3, 5, 1, 10, 20, 0, 5, 1, -5, 0, …
## $ week_40 <dbl> 0, 0, 5, 1, 5, 1, 10, -5, -20, 3,…
# Changing some variables type to factors
hogwarts <- hogwarts |> mutate(
across(c(house, course, sex, wandCore, bloodStatus), ~ as.factor(.x))
)
summary (hogwarts)
## id house course sex wandCore
## Min. : 1.0 Gryffindor:126 1: 80 female:333 dragon heartstring:196
## 1st Qu.:140.8 Hufflepuff:179 2:101 male :227 phoenix feather :181
## Median :280.5 Ravenclaw :122 3: 67 unicorn hair :183
## Mean :280.5 Slytherin :133 4: 71
## 3rd Qu.:420.2 5: 88
## Max. :560.0 6: 67
## 7: 86
## bloodStatus result Defence against the dark arts exam
## half-blood :391 Min. :-292.00 Min. : 0
## muggle-born: 60 1st Qu.: 7.00 1st Qu.:39
## pure-blood :109 Median : 70.50 Median :49
## Mean : 59.71 Mean :48
## 3rd Qu.: 128.25 3rd Qu.:58
## Max. : 260.00 Max. :89
##
## Flying exam Astronomy exam Herbology exam Divinations exam
## Min. : 0.00 Min. : 0.00 Min. : 0.00 Min. : 0.00
## 1st Qu.:36.00 1st Qu.:37.00 1st Qu.:39.00 1st Qu.:38.00
## Median :48.00 Median :49.00 Median :49.00 Median :49.00
## Mean :47.37 Mean :47.99 Mean :47.75 Mean :48.44
## 3rd Qu.:60.00 3rd Qu.:60.00 3rd Qu.:58.00 3rd Qu.:59.00
## Max. :85.00 Max. :87.00 Max. :86.00 Max. :89.00
##
## Charms exam History of magic exam Arithmancy exam
## Min. : 0.00 Min. : 0.00 Min. : 0.00
## 1st Qu.:39.00 1st Qu.:37.00 1st Qu.:38.00
## Median :49.00 Median :48.00 Median :50.00
## Mean :48.36 Mean :47.28 Mean :48.38
## 3rd Qu.:59.00 3rd Qu.:58.00 3rd Qu.:60.00
## Max. :98.00 Max. :85.00 Max. :91.00
##
## Care of magical creatures exam Muggle studies exam Study of ancient runes exam
## Min. : 0.00 Min. : 0.00 Min. : 0.00
## 1st Qu.:38.00 1st Qu.:38.00 1st Qu.:38.00
## Median :49.00 Median :50.00 Median :48.00
## Mean :48.11 Mean :48.64 Mean :47.44
## 3rd Qu.:60.00 3rd Qu.:61.00 3rd Qu.:58.00
## Max. :95.00 Max. :94.00 Max. :89.00
##
## Transfiguration exam Potions exam week_1 week_2
## Min. : 0.00 Min. : 0.00 Min. :-20.000 Min. :-20.000
## 1st Qu.: 34.00 1st Qu.: 21.00 1st Qu.: -3.000 1st Qu.: -3.000
## Median : 49.00 Median : 47.00 Median : 1.000 Median : 1.000
## Mean : 48.24 Mean : 46.62 Mean : 1.334 Mean : 1.161
## 3rd Qu.: 62.25 3rd Qu.: 68.00 3rd Qu.: 5.000 3rd Qu.: 5.000
## Max. :100.00 Max. :100.00 Max. : 50.000 Max. : 20.000
##
## week_3 week_4 week_5 week_6
## Min. :-20.000 Min. :-20.00 Min. :-20.0000 Min. :-20.000
## 1st Qu.: -1.500 1st Qu.: -1.00 1st Qu.: -3.0000 1st Qu.: -1.000
## Median : 1.000 Median : 1.00 Median : 1.0000 Median : 1.000
## Mean : 1.407 Mean : 1.82 Mean : 0.9196 Mean : 1.448
## 3rd Qu.: 5.000 3rd Qu.: 5.00 3rd Qu.: 5.0000 3rd Qu.: 5.000
## Max. : 20.000 Max. : 20.00 Max. : 20.0000 Max. : 20.000
##
## week_7 week_8 week_9 week_10
## Min. :-20.000 Min. :-20.0 Min. :-50.00 Min. :-20.000
## 1st Qu.: -3.000 1st Qu.: -1.0 1st Qu.: -1.00 1st Qu.: -1.000
## Median : 1.000 Median : 1.0 Median : 1.00 Median : 1.000
## Mean : 1.529 Mean : 1.6 Mean : 1.63 Mean : 1.457
## 3rd Qu.: 5.000 3rd Qu.: 5.0 3rd Qu.: 5.00 3rd Qu.: 5.000
## Max. : 20.000 Max. : 20.0 Max. : 20.00 Max. : 20.000
##
## week_11 week_12 week_13 week_14
## Min. :-20.000 Min. :-20.000 Min. :-20.0000 Min. :-20.00
## 1st Qu.: -1.000 1st Qu.: -1.000 1st Qu.: -3.0000 1st Qu.: -1.00
## Median : 1.000 Median : 1.000 Median : 0.0000 Median : 1.00
## Mean : 1.586 Mean : 1.689 Mean : 0.7393 Mean : 1.53
## 3rd Qu.: 5.000 3rd Qu.: 5.000 3rd Qu.: 5.0000 3rd Qu.: 5.00
## Max. : 20.000 Max. : 20.000 Max. : 50.0000 Max. : 20.00
##
## week_15 week_16 week_17 week_18
## Min. :-20.000 Min. :-20.000 Min. :-20.0 Min. :-20.000
## 1st Qu.: -1.000 1st Qu.: -1.000 1st Qu.: -1.0 1st Qu.: -1.000
## Median : 1.000 Median : 1.000 Median : 1.0 Median : 1.000
## Mean : 1.738 Mean : 1.636 Mean : 1.8 Mean : 1.712
## 3rd Qu.: 5.000 3rd Qu.: 5.000 3rd Qu.: 5.0 3rd Qu.: 5.000
## Max. : 20.000 Max. : 20.000 Max. : 50.0 Max. : 20.000
##
## week_19 week_20 week_21 week_22
## Min. :-50.0000 Min. :-20.00 Min. :-20.000 Min. :-20.000
## 1st Qu.: -3.0000 1st Qu.: -3.00 1st Qu.: -1.000 1st Qu.: -1.000
## Median : 0.0000 Median : 1.00 Median : 1.000 Median : 1.000
## Mean : 0.8071 Mean : 1.55 Mean : 1.816 Mean : 1.527
## 3rd Qu.: 5.0000 3rd Qu.: 5.00 3rd Qu.: 5.000 3rd Qu.: 5.000
## Max. : 20.0000 Max. : 50.00 Max. : 20.000 Max. : 20.000
##
## week_23 week_24 week_25 week_26
## Min. :-20.0000 Min. :-20.000 Min. :-20.000 Min. :-20.000
## 1st Qu.: -3.0000 1st Qu.: -1.000 1st Qu.: -3.000 1st Qu.: -3.000
## Median : 0.0000 Median : 1.000 Median : 1.000 Median : 1.000
## Mean : 0.8036 Mean : 1.168 Mean : 1.364 Mean : 1.248
## 3rd Qu.: 5.0000 3rd Qu.: 5.000 3rd Qu.: 5.000 3rd Qu.: 5.000
## Max. : 20.0000 Max. : 20.000 Max. : 20.000 Max. : 20.000
##
## week_27 week_28 week_29 week_30
## Min. :-50.0 Min. :-20.000 Min. :-20.000 Min. :-20.000
## 1st Qu.: -1.0 1st Qu.: -1.500 1st Qu.: -1.000 1st Qu.: -1.000
## Median : 1.0 Median : 1.000 Median : 0.000 Median : 1.000
## Mean : 1.5 Mean : 1.923 Mean : 1.262 Mean : 1.705
## 3rd Qu.: 5.0 3rd Qu.: 5.000 3rd Qu.: 5.000 3rd Qu.: 5.000
## Max. : 20.0 Max. : 20.000 Max. : 20.000 Max. : 20.000
##
## week_31 week_32 week_33 week_34
## Min. :-20.00 Min. :-20.000 Min. :-20.000 Min. :-20.000
## 1st Qu.: -1.00 1st Qu.: -1.000 1st Qu.: -1.000 1st Qu.: -1.000
## Median : 1.00 Median : 1.000 Median : 1.000 Median : 1.000
## Mean : 1.68 Mean : 2.013 Mean : 1.539 Mean : 1.593
## 3rd Qu.: 5.00 3rd Qu.: 5.000 3rd Qu.: 5.000 3rd Qu.: 5.000
## Max. : 20.00 Max. : 20.000 Max. : 20.000 Max. : 20.000
##
## week_35 week_36 week_37 week_38
## Min. :-20.0 Min. :-20.000 Min. :-20.00 Min. :-20.000
## 1st Qu.: -1.0 1st Qu.: -1.000 1st Qu.: -1.00 1st Qu.: -1.000
## Median : 1.0 Median : 1.000 Median : 1.00 Median : 1.000
## Mean : 1.7 Mean : 2.079 Mean : 1.32 Mean : 1.864
## 3rd Qu.: 5.0 3rd Qu.: 5.000 3rd Qu.: 5.00 3rd Qu.: 5.000
## Max. : 20.0 Max. : 20.000 Max. : 20.00 Max. : 20.000
##
## week_39 week_40
## Min. :-20.000 Min. :-20.000
## 1st Qu.: -1.000 1st Qu.: -3.000
## Median : 1.000 Median : 0.000
## Mean : 1.438 Mean : 1.079
## 3rd Qu.: 5.000 3rd Qu.: 5.000
## Max. : 20.000 Max. : 20.000
##
sum(is.na(hogwarts))
## [1] 0
theme_custom <- theme(
panel.background = element_rect(fill = "white"),
plot.title = element_text(size = 25, hjust = 0.5),
plot.subtitle = element_text(size = 20, hjust = 0.5),
strip.text = element_text(size = 18),
axis.text = element_text(size = 18),
axis.title = element_text(size = 20),
legend.title = element_text(size = 20),
legend.text = element_text(size = 18),
legend.position = "right",
plot.margin=unit(c(1, 0.5, 1, 0.5),"cm")
)
theme_custom_small <- theme_custom +
theme(legend.position="top",
legend.title = element_text(size = 14),
legend.text = element_text(size = 14))
hogwarts |>
ggplot(aes (x = `result`, y =`Herbology exam` ))+
geom_point (shape= 3, size= 3)+
geom_smooth (method = "lm", se= FALSE, colour = "blue4")+
theme_custom
Scatterplot показывает тенденцию, что с увеличением результата за год (баллов) у студента увеличивается и оценка за экзамен по травологии (положительная корреляция). Между этими количественными величинами можно продположить взаимосвязь.
hogwarts |> select( house, result, `Herbology exam`, `Muggle studies exam`, `Potions exam`,`Divinations exam`)|>
pivot_longer(!c(house, result)) |>
ggplot(aes(x = `result`, y=`value`))+
geom_point (aes (color= `house`))+
geom_smooth(se = FALSE,
method = "lm")+
scale_color_manual(values = c("Gryffindor" = "#C50000",
"Hufflepuff" = "#ECB939",
"Ravenclaw" = "#41A6D9",
"Slytherin" = "#1F5D25"))+
facet_wrap(~`name`, ncol = 2)+
theme(aspect.ratio = 1)+
theme_custom
##### 3. Result vs 4 exams - modification
hogwarts |> select( house, result, `Herbology exam`, `Muggle studies exam`, `Potions exam`,`Divinations exam`)|>
pivot_longer(!c(house, result)) |>
ggplot(aes(x = `result`, y=`value`))+
geom_point (aes (fill = `house`), shape = 21 , size = 2, stroke =0.1)+
geom_smooth(aes (color = (`name`== "Potions exam")),
se = FALSE,
method = "lm", show.legend = F)+
#scale_color_discrete (name = "exam", labels = c("TRUE"= "Potions exam", "FALSE" = "Other"))+
scale_fill_manual(values = c("Gryffindor" = "#C50000",
"Hufflepuff" = "#ECB939",
"Ravenclaw" = "#41A6D9",
"Slytherin" = "#1F5D25"))+
facet_wrap(~`name`, ncol = 2)+
theme(aspect.ratio = 1) +
theme_custom
Постройте барплот (столбиковую диаграмму) распредления набранных баллов за первый семестр (с 1-й по 17-ю неделю включительно) у студентов разного происхождения. Если у вас возникают трудности, можете обратиться к шпаргалке по dplyr от posit. Выдвиньте гипотезу (или гипотезы), почему распределение получилось именно таким. (1 б.)
res_1 <- hogwarts |> select (house, bloodStatus,21:37) |> mutate (res_1sem = rowSums(across(where(is.numeric)))) |> select (house, bloodStatus,last_col() ) |> group_by (bloodStatus) |> summarise (res_1sem = sum(res_1sem), count = n())
ggplot(res_1)+
geom_col(aes(x= bloodStatus, y= res_1sem, fill=bloodStatus ))+
xlab (label = "blood status")+
ylab (label = "result for 1 semester")+
scale_fill_brewer(palette = "BuPu")+
theme_custom
Гипотеза 1- полукровки более упорны в учебе, так как не так уверены в
себе, как чистокровные волшебники. В то время как результат
маглорожденных ниже, так как им тяжелее дается учеба в силу трудностей
адаптации и воспитания. Гипотеза 2- значительно более высокий балл
полукровок объясняется тем, что их значительно больше, чем других групп
студентов по происхождению.
Модифицируйте предыдущий график – отсортируйте столбцы в порядке убывания суммы баллов. Добавьте на график текстовые метки, отражающие число студентов каждого происхождения. Попробуйте использовать для этой задачи не geom_text, а geom_label. Настройте внешний вид geom_label по своему усмотрению. Поправьте название оси. Проинтерпретируйте график. Соотносится ли интерпретация с вашей гипотезой из пункта 1? (1 б.)
ggplot(res_1, aes(x= fct_reorder (bloodStatus, res_1sem, .desc= T), y= res_1sem, fill=bloodStatus ))+
geom_col()+
xlab (label = "blood_status")+
scale_fill_brewer(palette = "BuPu")+
geom_label(
label=res_1$count,
nudge_x = 0.1, nudge_y = 0.1,
check_overlap = T, size= 8, show_guide = FALSE
)+
xlab (label = "blood status")+
ylab (label = "result for 1 semester")+
theme_custom
Интерпретация:по числу баллов за первый семестр полукровки значительно
превосходят как маглорожденных, так и чистокровных, так как их
значительно больше. Визуальна заметна тенденция: чем ниже кол-во
студентов в группе - тем меньше результат за 1 семестр. Для корректного
сравнения успеваемости групп студентов по происхождению нужно
использовать, например, среднее значение полученных баллов в каждой
группе (с указанием ошибки, либо ДИ).
res_2<- hogwarts |> select (house, sex, bloodStatus,21:37) |> mutate (res_1sem = rowSums(across(where(is.numeric)))) |> select (sex, bloodStatus,last_col() ) |> group_by (bloodStatus, sex) |> summarise (res_1sem = sum(res_1sem)) |>
mutate (bloodStatusandsex= paste0 ( bloodStatus, " ", sex))
bloodStatus_gender_barplot<-ggplot(res_2,aes(y = fct_reorder(bloodStatusandsex, res_1sem, .desc = FALSE),
x = res_1sem,
fill= bloodStatus) )+
geom_col()+
scale_x_continuous(breaks= seq (-1000,11000,1000))+
labs(x ="Результат за 1 семестр", y = "Происхождение и пол", title = "Результат за 1 семестр", caption = "Для курса по биостатистике")+
geom_text(aes(x = max(res_1sem) + 1400, label = res_1sem), size = 8,
position = position_dodge(width = 1))+
scale_fill_brewer(name= "Происхождение", labels = c("полукровки","маглорожденные", "чистокровные"), palette = "Accent")+
theme_custom
bloodStatus_gender_barplot
ggsave ("bloodStatus_gender_barplot.png", bloodStatus_gender_barplot, width = 20, height = 16, units = "in", dpi = 300)
Функция делает, в большинстве случаев,то же самое, что изменение положение координат при создании эстетики (aes) или опциональная настройка аргумента ориентации в слоях geom и stat.
В документаци сказано, что coord_flip() полезна для геомов и
статистик которые не поддерживают настройки ориентации и конвертации
отображения у, зависимого от x, в отображение х, зависимого от y.
Пользователи отмечают что, например geom_density_ridges, не поддерживает
изменение ориентации, поэтому для него использование coord_flip()
оправдано.
Среди минусов: при применении не сохраняет заданный порядок факторов. Также плохо работает с фасетированеим.
potions_runes <-hogwarts |> select (house, bloodStatus, sex, `Potions exam`, `Study of ancient runes exam`)
potions_runes_l <-hogwarts |> select (house, bloodStatus, sex, `Potions exam`, `Study of ancient runes exam`) |>
pivot_longer(cols = c(`Potions exam`, `Study of ancient runes exam`), names_to = "class", values_to = "score")
potions_runes_sum <-potions_runes_l |> group_by(bloodStatus, class) |> summarise (mean = mean(score)|>round(2) ,
CI_L = (mean(score, na.rm = TRUE) - (1.96 * sd(score, na.rm = TRUE)/sqrt (length(hogwarts))) |> round(2)),
CI_U = (mean(score, na.rm = TRUE) + (1.96 * sd(score, na.rm = TRUE)/sqrt (length(hogwarts))) |> round(2)))
sctr <- ggplot(potions_runes, aes(x = `Potions exam`,
y = `Study of ancient runes exam`, colour = house))+
geom_point(alpha = 0.7, size =2)+
geom_smooth( method = "lm", se= F)+
scale_color_manual(values = c("Gryffindor" = "#C50000",
"Hufflepuff" = "#ECB939",
"Ravenclaw" = "#41A6D9",
"Slytherin" = "#1F5D25") )+
theme_custom_small+
theme (legend.position = "right")
bxpl <- ggplot(potions_runes_l, aes(x = `class`,
y = `score`, colour = house))+
geom_boxplot(lwd= 1.5, width= 0.4, position=position_dodge(0.7), fill = "gray90")+
scale_color_manual(values = c("Gryffindor" = "#C50000",
"Hufflepuff" = "#ECB939",
"Ravenclaw" = "#41A6D9",
"Slytherin" = "#1F5D25"))+
theme_custom_small
ptrng <- ggplot(potions_runes_sum)+
geom_pointrange(aes(x=class,
y= mean, ymin = CI_L, ymax = CI_U, group=bloodStatus ,color = bloodStatus),
linewidth = 2,
size = 1.3, position=position_dodge(width = .5) )+
scale_color_manual(values = c("half-blood" = "coral",
"muggle-born" = "bisque2",
"pure-blood" = "deeppink4"))+
ylim (25,65)+
theme_custom_small
ggarrange(
ggarrange(bxpl,ptrng , ncol = 2, labels = c("A", "B")),
ggarrange(sctr, labels = "C"),
nrow = 2 )
Визуализируйте средний балл по зельеварению студентов с различным происхождением. Вы вольны добавить дополнительные детали и информацию на график. Проинтерпретируйте результат. Как вы думаете, почему он именно такой? Если у вас есть гипотеза, проиллюстрируйте ее еще одним графиком (или графиками). Объедините их при помощи ggarrange. (по 1 б. за первый и график и правильную интерпретацию с подтверждением в виде второго графика и текстовой аргументации). Измените порядок ваших фигур на первом графике слева направо следующим образом: маглорожденные,, чистокровные, полукровки.
Скорректируйте название оси. Если у вас возникают сложности, обратитесь к шпаргалке по пакету forcats от posit. (Дополнительные 0.5 б.)
Средний балл по зелье студентов с разл происх
blstat<- hogwarts |> select (bloodStatus, `Potions exam`)|> group_by(bloodStatus) |> summarise (mean = (mean(`Potions exam`)|>round(2)),
sd = (sd(`Potions exam`) |> round(2))) |>
mutate(bloodStatus= fct_relevel(bloodStatus,
"muggle-born", "pure-blood", "half-blood"))
bldst_means<- ggplot(blstat, aes(x=bloodStatus,
y= mean))+
geom_pointrange(aes(ymin = mean+sd,
ymax= mean-sd,
color=bloodStatus ),
linewidth = 2,
size= 1.5,
fatten = 4)+
scale_color_manual(values = c("half-blood" = "coral",
"muggle-born" = "bisque2",
"pure-blood" = "deeppink4"))+
labs(x ="blood status", y = "score", title = "Potions exam result (Mean \u00B1 SD)")+
geom_label(
label= paste0 (blstat$mean,"\u00B1",blstat$sd),
nudge_x = 0.2, nudge_y =20,
check_overlap = T, size= 6, show_guide = FALSE
)+
geom_hline(linetype = "dotted", yintercept = 50, size = 1, color = "gray60")+
ylim (0,100)+
theme_custom +
theme (legend.position = "top")
bldst_means
Наибольший средний балл за экзамен по зельеварению наблюдается у
чистокловных студентов, наименьший- у маглорожденных студентов. При этом
результат скорее всего не является статистически значимым.Однако можно
выдвинуть две гипотезы: либо преподаватель предвзят и реальные успехи
маглорожденных студентов не отличаются от студентов другого
происхождения, либо маглорожденные студенты имеют в целом худшую
успеваемость (альтернативная гипотеза). Это можно проверить, сравнив
успеваемость студентов а) по среднему колличеству баллов, которые они
приносят факультету, б) по средним результатам нескольким другим
дисциплинам (найти условно более сложные экзамены по анализу summary не
удалось).
bldst_resm <- hogwarts |> select (bloodStatus, result)|> group_by(bloodStatus) |> summarise (mean = (mean(result)|>round(2)),
sd = (sd(result) |> round(2)))|>
mutate(bloodStatus= fct_relevel(bloodStatus,
"muggle-born", "pure-blood", "half-blood")) |>
ggplot ()+
geom_pointrange(aes(x=bloodStatus, y= mean, ymin = mean+sd,
ymax= mean-sd,
color=bloodStatus),
linewidth = 2,
size= 1.5,
fatten = 4)+
scale_color_manual(values = c("half-blood" = "coral",
"muggle-born" = "bisque2",
"pure-blood" = "deeppink4"))+
labs(x ="blood status", y = "result (Mean \u00B1 SD)", title = "Year result (Mean \u00B1 SD)", color = "Blood status") +
geom_hline(linetype = "dotted", yintercept = 50, size = 1, color = "gray60") +
theme_custom+
theme(legend.key = element_rect(color = "black"),
legend.key.spacing.y = unit(1, "cm"))
bldst_5_ex <- hogwarts |> select (bloodStatus, `Charms exam`,`Defence against the dark arts exam`,
`Study of ancient runes exam`, `Transfiguration exam`, `Arithmancy exam`)|>
group_by(bloodStatus) |> rowwise () |>
mutate (res_5_exams = mean(c_across(where(is.numeric)))) |>
select (bloodStatus,last_col()) |>
mutate(bloodStatus= fct_relevel(bloodStatus,"muggle-born", "pure-blood", "half-blood")) |>
ggplot (aes (x= bloodStatus, y = res_5_exams, fill = bloodStatus))+
geom_boxplot()+
stat_summary(fun.y=mean, geom="point", shape=20, size=14, color="red", fill="red")+
scale_fill_manual(values = c("half-blood" = "coral",
"muggle-born" = "bisque2",
"pure-blood" = "deeppink4"))+
labs(x ="blood status", y = " aver. score for 5 exams", title = "Average result for 5 exams")+
theme_custom
ggarrange( bldst_means + theme (legend.position = "none" ),
bldst_resm + theme (legend.position = c(0.5, -0.7)),
bldst_5_ex + theme (legend.position = "none"))
#library(extrafont)
#font_import()
loadfonts(quiet = T)
#fonts()
theme_custom_spec <- theme(
panel.background = element_rect(fill = "white", colour = NA),
panel.grid.major = element_line(colour = NA, size = 0.2),
panel.grid.minor = element_line(colour = NA, size = 0.5),
panel.margin = unit(0.25, "lines"),
axis.ticks = element_line(linewidth = 1, color = "grey50"),
axis.ticks.length.y = unit(.1, "cm"),
text = element_text(family = "serif"),
legend.text = element_text(size= 22, face ="italic"),
legend.title = element_text(size= 22, hjust = 0),
legend.position = c(0.5, 0.1),
axis.text.x = element_text(colour = NA, lineheight = 0.9, vjust = 1),
axis.text.y = element_text(lineheight = 0.9, size= 20, hjust = 1),
axis.title.y =element_text( size = 24, vjust = 0.5),
axis.title.x =element_text(color= NA, size = 20, vjust = 0.5),
plot.title = element_text(size = 28, hjust = 0.5),
plot.subtitle = element_text(color= "darkgoldenrod4", size = 18, hjust = 0.5, family = "sans" ),
plot.caption = element_text(size = 11, margin=margin(t = -25, unit = "pt"), family = "Arial Narrow" ),
strip.background = element_rect(fill = "grey80", colour = "NA"),
strip.text.x = element_text(size = 22)
)
sex_rus <- as_labeller(c(
`male` = "Мальчики",
`female` = "Девочки"
))
hogwarts|> select(house, result, sex) |> group_by (house)|> mutate (housesums = mean (result)) |>
ggplot ()+
geom_violin(aes(y = `result`, x= `house`, fill = `house`), colour = "grey49",
bins = 40) +
geom_boxplot(aes(y = `result`, x= `house`), width=0.04, fill = "white", color = "gray60", outlier.colour = "gray60")+
stat_summary(aes(y = `housesums`, x= `house`), fun.y = mean, mult=1,
geom="point", shape = 23, size = 9, fill = "brown", stroke = 1.5, show.legend = F)+
geom_hline(linetype ='dashed', yintercept = 0,size = 1.5, color = "coral")+
scale_fill_manual(values = c("Gryffindor" = "#C50000",
"Hufflepuff" = "#ECB939",
"Ravenclaw" = "#41A6D9",
"Slytherin" = "#1F5D25"),
labels = c ("Gryffindor" = "Гриффиндор",
"Hufflepuff" = "Пуффендуй",
"Ravenclaw" = "Когтевран",
"Slytherin" = "Слизерин")) +
scale_y_continuous(breaks= seq (-300,300,50))+
labs(y = "Количество очков", title = "Баллы студентов Хогвартса",
subtitle = "Распределение числа баллов у студентов различных факультетов Хогвартса в 2023-2024 учебном году",
caption = "Источник: нездоровая фантазия автора лекции", fill = "Факультет") +
facet_grid(~`sex`, labeller = sex_rus)+
theme_custom_spec
#hogwarts |> group_by(sex, house, course) |> summarize(across(.cols = where(is.numeric),.fns = mean))
Интерпретация: График violin-plot отражает распределение (плотности верояности) результата студентов,т.е. накопленных баллов за год, в зависимости от факультета с фасетированием по полу. Ромбики показывают среднюю сумму баллов по всем студентам факультета без разбиения (фасетирования) по полу, т.е. одинаковы для мальчиков и девочек. Линия по оси Y резделяет график на область положительных и отрицательных значений баллов.
Согласно графику наибольшая успеваемость у М и Д Когтеврана. Также разброс результата (по длине violin) наименьший для Д и М Когтеврана. По плотностям распределения и боксплотам можно заключить, что Девочки Когтевна и Слизерина приносят больше баллов в течение года своему факультету, чем Мальчики, в то время как на Гриффиндрое мальчики, напротив, скорее более успешны. Наиболее значимо различие между полами в случае Слизерина - Девочки почти так же успешны как ученицы Когтеврана, а мальчики, напротив, лишь отнимают очки (медиана порядка -150). Такое различие между Мальчиками и Девочками приводит к тому, что средний балл всех студентов Слизерина ниже, чем у всех других факультетов.